home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Controls / Visual Basic Controls.iso / vbcontrol / edgetext / clscompa.cl_ / clscompa.cl
Encoding:
Visual Basic class definition  |  1998-06-27  |  37.6 KB  |  1,124 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "clsCompany"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11. '**************************************************************************************
  12. 'Title:     clsCompany.cls
  13. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  14. 'Purpose:   This class allows single record access to the Company Table
  15. 'Properties:Equate to the fields in the table
  16. 'Methods:   Allow for record manipulation
  17.  
  18. 'This is commented because it is recommended that objError be declared global
  19. 'The reason for this is so that the DisplayFlag and writeToFile properties will
  20. 'be persistent
  21. 'Private objError as new clsError
  22.  
  23. 'It is recommended that the Database object Dbtimesheet be declared global
  24.  
  25. 'It is also recommended that the Configuration object be declared global if it is being used
  26. 'This is so that it can be persistent
  27. '**************************************************************************************
  28.  
  29. 'Here are the Field Properties for this table Class
  30. Public Company_Id As Integer
  31. Public Company_Name As String
  32. Public Address1 As String
  33. Public Address2 As String
  34. Public City As String
  35. Public State As String
  36. Public Zip As String
  37. Public Phone As String
  38. Public Fax As String
  39. Public Contact As String
  40. Public Updated_By As String
  41. Public Update_Module As String
  42. Public Update_Time As String
  43.  
  44. 'These are the ScratchPad Variables
  45. Private mCompany_Id As Integer
  46. Private mCompany_Name As String
  47. Private mAddress1 As String
  48. Private mAddress2 As String
  49. Private mCity As String
  50. Private mState As String
  51. Private mZip As String
  52. Private mPhone As String
  53. Private mFax As String
  54. Private mContact As String
  55. Private mUpdated_By As String
  56. Private mUpdate_Module As String
  57. Private mUpdate_Time As String
  58.  
  59. 'This public variable tells whether a function was successful, it is True when a function
  60. 'is successful, and false when a function is unsuccessful
  61. Public Success As Boolean
  62. 'This is the Error Code which was generated in the function call, it matches Err from VB
  63. Public ErrorCode As Double
  64. 'This is the Error message which was generated in the function call, it matches Errors(0) VB
  65. Public ErrorMessage As String
  66.  
  67.  
  68. '********************************************************************************************************
  69. 'Title:     CreateTable
  70. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  71. 'Purpose:   This subroutine Creates the very table that this class was created to read and write
  72. 'Parameters:None
  73. 'Return:    Nothing
  74. '********************************************************************************************************
  75. Public Sub CreateTable()
  76.  
  77. Dim lsSelect As String
  78. Dim RetCode As Integer, liCount As Integer, BadCount As Integer
  79.  
  80.     'The Success flag gets initialized to True and set to false if a trappable error occurs
  81.     Success = True
  82.     'The ErrorCode is the Err returned by VB for the Trapped Error
  83.     ErrorCode = False
  84.     'The DebugFlag is the provision which turns off all error checking in the table class when false
  85.     If Not objConfiguration.DebugFlag Then
  86.         On Error GoTo NoCompanyCreateTable
  87.     End If
  88.  
  89.  
  90.     'Assemble the SQL String
  91.     lsSelect = "Create Table COMPANY ("
  92.     lsSelect = lsSelect & "Company_Id Integer(2),"
  93.     lsSelect = lsSelect & "Company_Name String(100),"
  94.     lsSelect = lsSelect & "Address1 String(50),"
  95.     lsSelect = lsSelect & "Address2 String(50),"
  96.     lsSelect = lsSelect & "City String(50),"
  97.     lsSelect = lsSelect & "State String(2),"
  98.     lsSelect = lsSelect & "Zip String(10),"
  99.     lsSelect = lsSelect & "Phone String(50),"
  100.     lsSelect = lsSelect & "Fax String(50),"
  101.     lsSelect = lsSelect & "Contact String(100),"
  102.     lsSelect = lsSelect & "Updated_By String(50),"
  103.     lsSelect = lsSelect & "Update_Module String(50),"
  104.     lsSelect = lsSelect & "Update_Time Date/Time(8))"
  105.  
  106.     'Execute the SQL
  107.     dbTimeSheet.Execute lsSelect
  108.     On Error GoTo 0
  109.     Exit Sub
  110.  
  111. NoCompanyCreateTable:
  112.  
  113.     Success = False
  114.     ErrorCode = Err
  115.     objError.ErrorCode = Err
  116.     objError.FunctionName = "clsCompany.CreateTable"
  117.     If Err = 3146 Then
  118.         objError.Message = "Company, CreateTable " & vbCrLf & Errors(0) & " "
  119.         ErrorMessage = Errors(0)
  120.     Else
  121.         objError.Message = "Company, CreateTable "
  122.         ErrorMessage = Error(Err)
  123.     End If
  124.     objError.SQL = lsSelect
  125.     objError.Display vbExclamation
  126.     Resume Next
  127.  
  128.  
  129. End Sub
  130.  
  131.  
  132. '********************************************************************************************************
  133. 'Title:     AddItem
  134. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  135. 'Purpose:   This method Adds Items to the Database after the Key properties
  136. '           of the class have been filled
  137. 'Parameters:None
  138. 'Return:    Nothing
  139. '********************************************************************************************************
  140. Public Sub AddItem()
  141.  
  142. Dim lsSelect As String
  143. Dim RetCode As Integer, liCount As Integer, BadCount As Integer
  144.  
  145.     'The Success flag gets initialized to True and set to false if a trappable error occurs
  146.     Success = True
  147.     'The ErrorCode is the Err returned by VB for the Trapped Error
  148.     ErrorCode = False
  149.     'The DebugFlag is the provision which turns off all error checking in the table class when false
  150.     If Not objConfiguration.DebugFlag Then
  151.         On Error GoTo NoCompanyAddItem
  152.     End If
  153.  
  154.     'First we assign all the properties to temp vars and set any blank dates to NULL, or put in the date delimiters (Database Dependent)
  155.     StoreProperties
  156.     SetDefaultDates
  157.  
  158.     'Now Pad fields with a space if the record cannot be added with zero length
  159.     PadFields
  160.  
  161.     'The Double Your Quotes routine doubles any single quotes in string type variables for SQL compatibility
  162.     DoubleYourQuotes
  163.  
  164.     'Assemble the SQL String
  165.     lsSelect = "Insert into COMPANY ("
  166.     'First the Field List
  167.     lsSelect = lsSelect & "Company_Id,"
  168.     lsSelect = lsSelect & "Company_Name,"
  169.     lsSelect = lsSelect & "Address1,"
  170.     lsSelect = lsSelect & "Address2,"
  171.     lsSelect = lsSelect & "City,"
  172.     lsSelect = lsSelect & "State,"
  173.     lsSelect = lsSelect & "Zip,"
  174.     lsSelect = lsSelect & "Phone,"
  175.     lsSelect = lsSelect & "Fax,"
  176.     lsSelect = lsSelect & "Contact,"
  177.     lsSelect = lsSelect & "Updated_By,"
  178.     lsSelect = lsSelect & "Update_Module,"
  179.     lsSelect = lsSelect & "Update_Time)"
  180.     lsSelect = lsSelect & " Values("
  181.     'Now the Value List
  182.     lsSelect = lsSelect & "" & Format(Company_Id) & ","
  183.     lsSelect = lsSelect & "'" & Company_Name & "',"
  184.     lsSelect = lsSelect & "'" & Address1 & "',"
  185.     lsSelect = lsSelect & "'" & Address2 & "',"
  186.     lsSelect = lsSelect & "'" & City & "',"
  187.     lsSelect = lsSelect & "'" & State & "',"
  188.     lsSelect = lsSelect & "'" & Zip & "',"
  189.     lsSelect = lsSelect & "'" & Phone & "',"
  190.     lsSelect = lsSelect & "'" & Fax & "',"
  191.     lsSelect = lsSelect & "'" & Contact & "',"
  192.     'These are the Audit Trail Fields
  193.     lsSelect = lsSelect & "'" & objConfiguration.LanId & "',"
  194.     lsSelect = lsSelect & "'" & objConfiguration.ModuleName & "',"
  195.     lsSelect = lsSelect & "#" & Format(Now, "MM/DD/YYYY hh:mm:ss") & "#)"
  196.  
  197.     'Execute the SQL
  198.     dbTimeSheet.Execute lsSelect
  199.  
  200.     'Reassign the original values to the properties list
  201.     RetrieveProperties
  202.  
  203.     On Error GoTo 0
  204.     Exit Sub
  205.  
  206. NoCompanyAddItem:
  207.  
  208.     Success = False
  209.     ErrorCode = Err
  210.     objError.ErrorCode = Err
  211.     objError.FunctionName = "clsCompany.AddItem"
  212.     If Err = 3146 Then
  213.         objError.Message = "Company, AddItem " & vbCrLf & Errors(0) & " "
  214.         ErrorMessage = Errors(0)
  215.     Else
  216.         objError.Message = "Company, AddItem "
  217.         ErrorMessage = Error(Err)
  218.     End If
  219.     objError.SQL = lsSelect
  220.     objError.Display vbExclamation
  221.     Resume Next
  222.  
  223.  
  224. End Sub
  225.  
  226. '********************************************************************************************************
  227. 'Title:     ClearValues
  228. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  229. 'Purpose:   This method clears all fields in the Table class
  230. 'Parameters:None
  231. 'Return:    Nothing
  232. '********************************************************************************************************
  233. Sub ClearValues()
  234.  
  235.     Company_Id = 0
  236.     Company_Name = ""
  237.     Address1 = ""
  238.     Address2 = ""
  239.     City = ""
  240.     State = ""
  241.     Zip = ""
  242.     Phone = ""
  243.     Fax = ""
  244.     Contact = ""
  245.     Updated_By = ""
  246.     Update_Module = ""
  247.     Update_Time = ""
  248.  
  249. End Sub
  250.  
  251.  
  252. '********************************************************************************************************
  253. 'Title:     DeleteItem
  254. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  255. 'Purpose:   This method Deletes Items from the Database after the Key fields have been filled
  256. 'Parameters:None
  257. 'Return:    Nothing
  258. '********************************************************************************************************
  259. Public Sub DeleteItem()
  260.  
  261. Dim lrsData As Recordset
  262. Dim RetCode As Integer, lsCount As Integer, liCount As Integer, BadCount As Integer, lsSelect As String
  263.  
  264.     'The Success flag gets initialized to True and set to false if a trappable error occurs
  265.     Success = True
  266.     'The ErrorCode is the Err returned by VB for the Trapped Error
  267.     ErrorCode = False
  268.     'The DebugFlag is the provision which turns off all error checking in the table class when false
  269.     If Not objConfiguration.DebugFlag Then
  270.         On Error GoTo NoCompanyDeleteItem
  271.     End If
  272.  
  273.     'First we assign all the properties to temp vars and set any blank dates to NULL, or put in the date delimiters (Database Dependent)
  274.     StoreProperties
  275.     SetDefaultDates
  276.  
  277.     'Now Pad fields with a space if the record cannot be added with zero length
  278.     PadFields
  279.  
  280.     'The Double Your Quotes routine doubles any single quotes in string type variables for SQL compatibility
  281.     DoubleYourQuotes
  282.  
  283.     'Assemble the SQL String
  284.     lsSelect = "Delete from COMPANY  where Company_Id = " & Format(Company_Id) & ""
  285.  
  286.     'Execute the SQL
  287.      dbTimeSheet.Execute lsSelect
  288.  
  289.     'Now ReAssign the Temp vars back to the class props
  290.     RetrieveProperties
  291.  
  292.     On Error GoTo 0
  293.     Exit Sub
  294.  
  295. NoCompanyDeleteItem:
  296.  
  297.     Success = False
  298.     ErrorCode = Err
  299.     objError.ErrorCode = Err
  300.     objError.FunctionName = "clsCompany.DeleteItem"
  301.     If Err = 3146 Then
  302.         objError.Message = "Company, DeleteItem " & vbCrLf & Errors(0) & " "
  303.         ErrorMessage = Errors(0)
  304.     Else
  305.         objError.Message = "Company, DeleteItem "
  306.         ErrorMessage = Error(Err)
  307.     End If
  308.     objError.SQL = lsSelect
  309.     objError.Display vbExclamation
  310.     Resume Next
  311.  
  312.  
  313. End Sub
  314.  
  315.  
  316. '********************************************************************************************************
  317. 'Title:     FillObjectFromRecordset
  318. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  319. 'Purpose    This sub fills all the properties of the class from a given recordset
  320. 'Parameters:The recordset from which to fill
  321. 'Return:    Nothing
  322. '********************************************************************************************************
  323. Public Sub FillObjectFromRecordSet(lrsData As Recordset)
  324.  
  325. Dim liCount As Integer, BadCount As Integer, psSQL As String, lsSelect As String
  326.     If Not objConfiguration.DebugFlag Then
  327.         On Error GoTo NoCompanyFillObject
  328.     End If
  329.  
  330.     'Appending a & "" onto the end of a recordset field checks for Null values
  331.     'Similarly, Numbers are explicitly converted to eliminate Null values as well
  332.     Company_Id = Val(lrsData![Company_Id] & "")
  333.     Company_Name = lrsData![Company_Name] & ""
  334.     Address1 = lrsData![Address1] & ""
  335.     Address2 = lrsData![Address2] & ""
  336.     City = lrsData![City] & ""
  337.     State = lrsData![State] & ""
  338.     Zip = lrsData![Zip] & ""
  339.     Phone = lrsData![Phone] & ""
  340.     Fax = lrsData![Fax] & ""
  341.     Contact = lrsData![Contact] & ""
  342.     Updated_By = lrsData![Updated_By] & ""
  343.     Update_Module = lrsData![Update_Module] & ""
  344.     Update_Time = lrsData![Update_Time] & ""
  345.     On Error GoTo 0
  346.     Exit Sub
  347.  
  348. NoCompanyFillObject:
  349.  
  350.     Success = False
  351.     ErrorCode = Err
  352.     objError.ErrorCode = Err
  353.     objError.FunctionName = "clsCompany.FillObject"
  354.     If Err = 3146 Then
  355.         objError.Message = "Company, FillObject " & vbCrLf & Errors(0) & " "
  356.         ErrorMessage = Errors(0)
  357.     Else
  358.         objError.Message = "Company, FillObject "
  359.         ErrorMessage = Error(Err)
  360.     End If
  361.     objError.SQL = lsSelect
  362.     objError.Display vbExclamation
  363.     Resume Next
  364.  
  365.  
  366. End Sub
  367.  
  368.  
  369. '********************************************************************************************************
  370. 'Title:     GetItem
  371. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  372. 'Purpose:   This Method Gets a record from the database after the Key Fields have been Filled
  373. 'Parameters:The recordset from which to fill
  374. 'Return:    Nothing
  375. '********************************************************************************************************
  376. Public Sub GetItem()
  377.  
  378. Dim lrsData As Recordset
  379. Dim RetCode As Integer, lsCount As Integer, liCount As Integer, BadCount As Integer, lsSelect As String
  380.  
  381.     'The Success flag gets initialized to True and set to false if a trappable error occurs
  382.     Success = True
  383.     'The ErrorCode is the Err returned by VB for the Trapped Error
  384.     ErrorCode = False
  385.     'The DebugFlag is the provision which turns off all error checking in the table class when false
  386.     If Not objConfiguration.DebugFlag Then
  387.         On Error GoTo NoCompanyGetItem
  388.     End If
  389.  
  390.     'First we assign all the properties to temp vars and set any blank dates to NULL, or put in the date delimiters (Database Dependent)
  391.     StoreProperties
  392.     SetDefaultDates
  393.  
  394.     'Now Pad fields with a space if the record cannot be added with zero length
  395.     PadFields
  396.  
  397.     'The Double Your Quotes routine doubles any single quotes in string type variables for SQL compatibility
  398.     DoubleYourQuotes
  399.  
  400.     'Assemble the SQL String
  401.     lsSelect = "Select * from COMPANY  where Company_Id = " & Format(Company_Id) & ""
  402.  
  403.     'Execute the SQL
  404.     Set lrsData = dbTimeSheet.OpenRecordset(lsSelect, dbOpenSnapshot)
  405.  
  406.     'Now ReAssign the Temp vars back to the class props
  407.     RetrieveProperties
  408.  
  409.     'Check for a valid record
  410.     If Not Success Then
  411.         Exit Sub
  412.     End If
  413.     If lrsData.RecordCount = 0 Then
  414.         Success = False
  415.         Exit Sub
  416.     End If
  417.  
  418.     'Fill the Table Class Fields from the Recordset
  419.     FillObjectFromRecordSet lrsData
  420.     'Check for Errors
  421.     If Not Success Then
  422.         Exit Sub
  423.     End If
  424.     lrsData.Close
  425.  
  426.     'Now trim the spaces out of the padded fields
  427.     TrimPaddedFields
  428.  
  429.     'Strip the NULLs or bad dates out of date fields
  430.     StripDates False
  431.  
  432.     On Error GoTo 0
  433.     Exit Sub
  434.  
  435. NoCompanyGetItem:
  436.  
  437.     Success = False
  438.     ErrorCode = Err
  439.     objError.ErrorCode = Err
  440.     objError.FunctionName = "clsCompany.GetItem"
  441.     If Err = 3146 Then
  442.         objError.Message = "Company, GetItem " & vbCrLf & Errors(0) & " "
  443.         ErrorMessage = Errors(0)
  444.     Else
  445.         objError.Message = "Company, GetItem "
  446.         ErrorMessage = Error(Err)
  447.     End If
  448.     objError.SQL = lsSelect
  449.     objError.Display vbExclamation
  450.     Resume Next
  451.  
  452.  
  453. End Sub
  454.  
  455.  
  456. '********************************************************************************************************
  457. 'Title:     GetNewId
  458. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  459. 'Purpose:   This Method Gets a new Id using the Max function in SQL, it has only limited value, but is included as
  460. '           a template for new Primary Key generation
  461. 'Parameters:None
  462. 'Return:    Nothing
  463. '********************************************************************************************************
  464. Public Function GetNewId() As Double
  465.  
  466. Dim lrsData As Recordset
  467. Dim RetCode As Integer, liCount As Integer, BadCount As Integer, lsSelect As String
  468.  
  469.     'The Success flag gets initialized to True and set to false if a trappable error occurs
  470.     Success = True
  471.     'The ErrorCode is the Err returned by VB for the Trapped Error
  472.     ErrorCode = False
  473.     'The DebugFlag is the provision which turns off all error checking in the table class when false
  474.     If Not objConfiguration.DebugFlag Then
  475.         On Error GoTo NoCompanyGetNewId
  476.     End If
  477.  
  478.     'First we assign all the date and text properties to temp vars and set any blank dates to NULL, or put in the date delimiters (Database Dependent)
  479.     StoreProperties
  480.     SetDefaultDates
  481.  
  482.     'Now Pad fields with a space if the record cannot be added with zero length
  483.     PadFields
  484.  
  485.     'The Double Your Quotes routine doubles any single quotes in string type variables for SQL compatibility
  486.     DoubleYourQuotes
  487.  
  488.  
  489.     'The SQL provided here is just a simple Get Max.  This would only be useful for very small tables
  490.     'If you anticipate this table growing past a few hundred rows, change this routine accordingly
  491.     'You might try keeping a table with the last Id stored as a field, which can then be updated when a
  492.     'new Id is required.
  493.  
  494.     'Assemble the SQL String
  495.     lsSelect = "Select Max(Company_Id) from COMPANY "
  496.  
  497.     'Execute the SQL
  498.     Set lrsData = dbTimeSheet.OpenRecordset(lsSelect, dbOpenSnapshot)
  499.  
  500.     'Now ReAssign the Temp vars back to the class props
  501.     RetrieveProperties
  502.  
  503.     'Don't forget to check for those NULLS
  504.     If Not IsNull(lrsData(0)) Then
  505.         GetNewId = lrsData(0) + 1
  506.     Else
  507.         GetNewId = 1
  508.     End If
  509.     lrsData.Close
  510.     On Error GoTo 0
  511.     Exit Function
  512.  
  513. NoCompanyGetNewId:
  514.  
  515.     Success = False
  516.     ErrorCode = Err
  517.     objError.ErrorCode = Err
  518.     objError.FunctionName = "clsCompany.GetNewId"
  519.     If Err = 3146 Then
  520.         objError.Message = "Company, GetNewId " & vbCrLf & Errors(0) & " "
  521.         ErrorMessage = Errors(0)
  522.     Else
  523.         objError.Message = "Company, GetNewId "
  524.         ErrorMessage = Error(Err)
  525.     End If
  526.     objError.SQL = lsSelect
  527.     objError.Display vbExclamation
  528.     Resume Next
  529.  
  530.  
  531. End Function
  532.  
  533.  
  534. '********************************************************************************************************
  535. 'Title:     ParseItem
  536. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  537. 'Purpose:   This method can parse fields which have values in them.  It will create an SQL criteria string
  538. '           using like statements for strings, and = statements for numbers and dates, this can be used
  539. '           in Query by Example screens with little or no modification
  540. 'Parameters:None
  541. 'Return:    The Parsed String for use in SQL
  542. '********************************************************************************************************
  543. Public Function ParseItem(piAndFlag As Integer) As String
  544.  
  545. Dim RetCode As Integer, liCount As Integer, lsSelect As String
  546. Dim BadCount As Integer, WildCard As String
  547.  
  548.     'The Success flag gets initialized to True and set to false if a trappable error occurs
  549.     Success = True
  550.     'The ErrorCode is the Err returned by VB for the Trapped Error
  551.     ErrorCode = False
  552.     'The DebugFlag is the provision which turns off all error checking in the table class when false
  553.     If Not objConfiguration.DebugFlag Then
  554.         On Error GoTo NoCompanyParseItem
  555.     End If
  556.  
  557.     'Change this based on your database, MS-Access uses the *, but SQL standard is the %
  558.     WildCard = "*'"
  559.     
  560.     'First we assign all the date and text properties to temp vars and set any blank dates to NULL, or put in the date delimiters (Database Dependent)
  561.     StoreProperties
  562.     SetDefaultDates
  563.  
  564.     'Now Pad fields with a space if the record cannot be added with zero length
  565.     PadFields
  566.     'The Double Your Quotes routine doubles any single quotes in string type variables for SQL compatibility
  567.     DoubleYourQuotes
  568.  
  569.  
  570.     If Company_Id <> 0 Then
  571.         If piAndFlag Then
  572.             lsSelect = lsSelect & " And "
  573.         Else
  574.             lsSelect = lsSelect & " Where "
  575.         End If
  576.         lsSelect = lsSelect & "Company.Company_Id = " & Format(Company_Id)
  577.         piAndFlag = True
  578.     End If
  579.  
  580.     If Trim(Company_Name) <> "" Then
  581.         If piAndFlag Then
  582.             lsSelect = lsSelect & " And "
  583.         Else
  584.             lsSelect = lsSelect & " Where "
  585.         End If
  586.         lsSelect = lsSelect & "Company.Company_Name like '" & Trim(Company_Name) & WildCard
  587.         piAndFlag = True
  588.     End If
  589.  
  590.     If Trim(Address1) <> "" Then
  591.         If piAndFlag Then
  592.             lsSelect = lsSelect & " And "
  593.         Else
  594.             lsSelect = lsSelect & " Where "
  595.         End If
  596.         lsSelect = lsSelect & "Company.Address1 like '" & Trim(Address1) & WildCard
  597.         piAndFlag = True
  598.     End If
  599.  
  600.     If Trim(Address2) <> "" Then
  601.         If piAndFlag Then
  602.             lsSelect = lsSelect & " And "
  603.         Else
  604.             lsSelect = lsSelect & " Where "
  605.         End If
  606.         lsSelect = lsSelect & "Company.Address2 like '" & Trim(Address2) & WildCard
  607.         piAndFlag = True
  608.     End If
  609.  
  610.     If Trim(City) <> "" Then
  611.         If piAndFlag Then
  612.             lsSelect = lsSelect & " And "
  613.         Else
  614.             lsSelect = lsSelect & " Where "
  615.         End If
  616.         lsSelect = lsSelect & "Company.City like '" & Trim(City) & WildCard
  617.         piAndFlag = True
  618.     End If
  619.  
  620.     If Trim(State) <> "" Then
  621.         If piAndFlag Then
  622.             lsSelect = lsSelect & " And "
  623.         Else
  624.             lsSelect = lsSelect & " Where "
  625.         End If
  626.         lsSelect = lsSelect & "Company.State like '" & Trim(State) & WildCard
  627.         piAndFlag = True
  628.     End If
  629.  
  630.     If Trim(Zip) <> "" Then
  631.         If piAndFlag Then
  632.             lsSelect = lsSelect & " And "
  633.         Else
  634.             lsSelect = lsSelect & " Where "
  635.         End If
  636.         lsSelect = lsSelect & "Company.Zip like '" & Trim(Zip) & WildCard
  637.         piAndFlag = True
  638.     End If
  639.  
  640.     If Trim(Phone) <> "" Then
  641.         If piAndFlag Then
  642.             lsSelect = lsSelect & " And "
  643.         Else
  644.             lsSelect = lsSelect & " Where "
  645.         End If
  646.         lsSelect = lsSelect & "Company.Phone like '" & Trim(Phone) & WildCard
  647.         piAndFlag = True
  648.     End If
  649.  
  650.     If Trim(Fax) <> "" Then
  651.         If piAndFlag Then
  652.             lsSelect = lsSelect & " And "
  653.         Else
  654.             lsSelect = lsSelect & " Where "
  655.         End If
  656.         lsSelect = lsSelect & "Company.Fax like '" & Trim(Fax) & WildCard
  657.         piAndFlag = True
  658.     End If
  659.  
  660.     If Trim(Contact) <> "" Then
  661.         If piAndFlag Then
  662.             lsSelect = lsSelect & " And "
  663.         Else
  664.             lsSelect = lsSelect & " Where "
  665.         End If
  666.         lsSelect = lsSelect & "Company.Contact like '" & Trim(Contact) & WildCard
  667.         piAndFlag = True
  668.     End If
  669.  
  670.     If Trim(Updated_By) <> "" Then
  671.         If piAndFlag Then
  672.             lsSelect = lsSelect & " And "
  673.         Else
  674.             lsSelect = lsSelect & " Where "
  675.         End If
  676.         lsSelect = lsSelect & "Company.Updated_By like '" & Trim(Updated_By) & WildCard
  677.         piAndFlag = True
  678.     End If
  679.  
  680.     If Trim(Update_Module) <> "" Then
  681.         If piAndFlag Then
  682.             lsSelect = lsSelect & " And "
  683.         Else
  684.             lsSelect = lsSelect & " Where "
  685.         End If
  686.         lsSelect = lsSelect & "Company.Update_Module like '" & Trim(Update_Module) & WildCard
  687.         piAndFlag = True
  688.     End If
  689.  
  690.     If IsDate(Update_Time) Then
  691.         If piAndFlag Then
  692.             lsSelect = lsSelect & " And "
  693.         Else
  694.             lsSelect = lsSelect & " Where "
  695.         End If
  696.         lsSelect = lsSelect & "Company.Update_Time = " & Update_Time
  697.         piAndFlag = True
  698.     End If
  699.  
  700.     'now reassign the temp values back to the properties
  701.     RetrieveProperties
  702.  
  703.     On Error GoTo 0
  704.     ParseItem = lsSelect
  705.     Exit Function
  706.  
  707. NoCompanyParseItem:
  708.  
  709.     Success = False
  710.     ErrorCode = Err
  711.     objError.ErrorCode = Err
  712.     objError.FunctionName = "clsCompany.ParseItem"
  713.     If Err = 3146 Then
  714.         objError.Message = "Company, ParseItem " & vbCrLf & Errors(0) & " "
  715.         ErrorMessage = Errors(0)
  716.     Else
  717.         objError.Message = "Company, ParseItem "
  718.         ErrorMessage = Error(Err)
  719.     End If
  720.     objError.SQL = lsSelect
  721.     objError.Display vbExclamation
  722.     Resume Next
  723.  
  724.  
  725. End Function
  726.  
  727.  
  728. '********************************************************************************************************
  729. 'Title:     UpdateItem
  730. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  731. 'Purpose:   This method updates a record in the database using the primary key, it is recommended that you
  732. '           Fill the Key Fields, use the get method, fill the fields which have changed,
  733. '           then call this method to perform the update
  734. 'Parameters:None
  735. 'Return:    Nothing
  736. '********************************************************************************************************
  737. Public Sub UpdateItem()
  738.  
  739. Dim lsSelect As String
  740. Dim RetCode As Integer, liCount As Integer, BadCount As Integer
  741.  
  742.     'The Success flag gets initialized to True and set to false if a trappable error occurs
  743.     Success = True
  744.     'The ErrorCode is the Err returned by VB for the Trapped Error
  745.     ErrorCode = False
  746.     'The DebugFlag is the provision which turns off all error checking in the table class when false
  747.     If Not objConfiguration.DebugFlag Then
  748.         On Error GoTo NoCompanyUpdateItem
  749.     End If
  750.  
  751.     'First we will assign the date properties to temp vars and set any blank dates to NULL, or put in the date delimiters (Database Dependent)
  752.     StoreProperties
  753.     SetDefaultDates
  754.  
  755.     'Now Pad fields with a space if the record cannot be added with zero length
  756.     PadFields
  757.  
  758.     'The Double Your Quotes routine doubles any single quotes in string type variables for SQL compatibility
  759.     DoubleYourQuotes
  760.  
  761.     'Assemble the SQL String
  762.     lsSelect = "Update COMPANY Set "
  763.     lsSelect = lsSelect & "Company_Name = '" & Company_Name & "',"
  764.     lsSelect = lsSelect & "Address1 = '" & Address1 & "',"
  765.     lsSelect = lsSelect & "Address2 = '" & Address2 & "',"
  766.     lsSelect = lsSelect & "City = '" & City & "',"
  767.     lsSelect = lsSelect & "State = '" & State & "',"
  768.     lsSelect = lsSelect & "Zip = '" & Zip & "',"
  769.     lsSelect = lsSelect & "Phone = '" & Phone & "',"
  770.     lsSelect = lsSelect & "Fax = '" & Fax & "',"
  771.     lsSelect = lsSelect & "Contact = '" & Contact & "',"
  772.     'These are the Audit Trail Fields
  773.     lsSelect = lsSelect & "Updated_By = '" & objConfiguration.LanId & "',"
  774.     lsSelect = lsSelect & "Update_Module = '" & objConfiguration.ModuleName & "',"
  775.     lsSelect = lsSelect & "Update_Time = #" & Format(Now, "MM/DD/YYYY hh:mm:ss") & "# "
  776.     lsSelect = lsSelect & " where Company_Id = " & Format(Company_Id) & ""
  777.  
  778.     'Execute the SQL
  779.     dbTimeSheet.Execute lsSelect
  780.  
  781.     'now reassign the temp values back to the properties
  782.     RetrieveProperties
  783.  
  784.     On Error GoTo 0
  785.     Exit Sub
  786.  
  787. NoCompanyUpdateItem:
  788.  
  789.     Success = False
  790.     ErrorCode = Err
  791.     objError.ErrorCode = Err
  792.     objError.FunctionName = "clsCompany.UpdateItem"
  793.     If Err = 3146 Then
  794.         objError.Message = "Company, UpdateItem " & vbCrLf & Errors(0) & " "
  795.         ErrorMessage = Errors(0)
  796.     Else
  797.         objError.Message = "Company, UpdateItem "
  798.         ErrorMessage = Error(Err)
  799.     End If
  800.     objError.SQL = lsSelect
  801.     objError.Display vbExclamation
  802.     Resume Next
  803.  
  804.  
  805. End Sub
  806.  
  807. '********************************************************************************************************
  808. 'Title:     DoubleYourQuotes
  809. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  810. 'Purpose:   This routine Doubles your Single Quotes in all string or memo
  811. '           fields in the class for SQL compatibility
  812. 'Parameters:None
  813. 'Return:    Nothing
  814. '********************************************************************************************************
  815. Private Sub DoubleYourQuotes()
  816.  
  817. Dim liCount As Integer, BadCount As Integer, lsSelect As String
  818.  
  819.     If Not objConfiguration.DebugFlag Then
  820.         On Error GoTo NoCompanyDoubleYourQuotes
  821.     End If
  822.  
  823.     'These lines double the single quotes in any string field in the class
  824.     Company_Name = SearchandDouble(Company_Name)
  825.     Address1 = SearchandDouble(Address1)
  826.     Address2 = SearchandDouble(Address2)
  827.     City = SearchandDouble(City)
  828.     State = SearchandDouble(State)
  829.     Zip = SearchandDouble(Zip)
  830.     Phone = SearchandDouble(Phone)
  831.     Fax = SearchandDouble(Fax)
  832.     Contact = SearchandDouble(Contact)
  833.     Updated_By = SearchandDouble(Updated_By)
  834.     Update_Module = SearchandDouble(Update_Module)
  835.     On Error GoTo 0
  836.     Exit Sub
  837.  
  838. NoCompanyDoubleYourQuotes:
  839.  
  840.     Success = False
  841.     ErrorCode = Err
  842.     objError.ErrorCode = Err
  843.     objError.FunctionName = "clsCompany.DoubleYourQuotes"
  844.     If Err = 3146 Then
  845.         objError.Message = "Company, DoubleYourQuotes " & vbCrLf & Errors(0) & " "
  846.         ErrorMessage = Errors(0)
  847.     Else
  848.         objError.Message = "Company, DoubleYourQuotes "
  849.         ErrorMessage = Error(Err)
  850.     End If
  851.     objError.SQL = lsSelect
  852.     objError.Display vbExclamation
  853.     Resume Next
  854.  
  855.  
  856. End Sub
  857.  
  858. '********************************************************************************************************
  859. 'Title:     SearchandDouble
  860. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  861. 'Purpose:   This Function will look for any single quotes in a string passed to it
  862. '           and double them for SQL compatibility
  863. 'Parameters:string to be modified
  864. 'Return:    the modified string
  865. '********************************************************************************************************
  866. Private Function SearchandDouble(lsBuf As String) As String
  867.  
  868. Dim liStrLen As Integer
  869. Dim liCurChar As Integer
  870. Dim liQuotePos As Integer
  871. Dim lsQuote As String
  872. Dim lsOutBuf As String
  873.  
  874.     lsQuote = "'"
  875.     liCurChar = 1
  876.     lsOutBuf = ""
  877.     
  878.     
  879.     liQuotePos = InStr(liCurChar, lsBuf, lsQuote)
  880.     If liQuotePos = 0 Then
  881.         lsOutBuf = lsBuf
  882.     Else
  883.         liStrLen = Len(lsBuf)
  884.         Do While liQuotePos > 0
  885.             lsOutBuf = lsOutBuf & Mid(lsBuf, liCurChar, liQuotePos - liCurChar + 1) & lsQuote
  886.             liCurChar = liQuotePos + 1
  887.             liQuotePos = InStr(liCurChar, lsBuf, lsQuote)
  888.         Loop
  889.         lsOutBuf = lsOutBuf & Mid(lsBuf, liCurChar, liStrLen)
  890.     End If
  891.  
  892.     SearchandDouble = lsOutBuf
  893.  
  894. End Function
  895.  
  896. '********************************************************************************************************
  897. 'Title:     SetDefaultDates
  898. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  899. 'Purpose:   This routine puts default date or NULL into blank or invalid date fields
  900. 'Parameters:None
  901. 'Return:    Nothing
  902. '********************************************************************************************************
  903. Private Sub SetDefaultDates()
  904.  
  905. Dim liCount As Integer, BadCount As Integer, lsSelect As String
  906.  
  907.     If Not objConfiguration.DebugFlag Then
  908.         On Error GoTo NoCompanySetDefaultDates
  909.     End If
  910.  
  911.     'These lines look at the dates in the class, and put a NULL or your default date
  912.      'depending on your data mode, when the date is
  913.     'blank or invalid, since this is what sql expects
  914.     If Not IsDate(Update_Time) Then
  915.         Update_Time = "NULL"
  916.     Else
  917.         Update_Time = "#" & Format(CDate(Update_Time), "MM/DD/YYYY HH:MM:SS") & "#"
  918.     End If
  919.     On Error GoTo 0
  920.     Exit Sub
  921.  
  922. NoCompanySetDefaultDates:
  923.  
  924.     Success = False
  925.     ErrorCode = Err
  926.     objError.ErrorCode = Err
  927.     objError.FunctionName = "clsCompany.SetDefaultDates"
  928.     If Err = 3146 Then
  929.         objError.Message = "Company, SetDefaultDates " & vbCrLf & Errors(0) & " "
  930.         ErrorMessage = Errors(0)
  931.     Else
  932.         objError.Message = "Company, SetDefaultDates "
  933.         ErrorMessage = Error(Err)
  934.     End If
  935.     objError.SQL = lsSelect
  936.     objError.Display vbExclamation
  937.     Resume Next
  938.  
  939.  
  940. End Sub
  941.  
  942. '********************************************************************************************************
  943. 'Title:     StripDates
  944. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  945. 'Purpose:   This routine strips NULLS and bad Dates from Fields in the class, the delimiter field
  946. '           determines whether it should check for the presence of Date Delimiters
  947. 'Parameters:None
  948. 'Return:    Nothing
  949. '********************************************************************************************************
  950. Private Sub StripDates(DelimiterFlag As Integer)
  951.  
  952. Dim liCount As Integer, BadCount As Integer, lsSelect As String
  953.  
  954.     If Not objConfiguration.DebugFlag Then
  955.         On Error GoTo NoCompanyStripDates
  956.     End If
  957.  
  958.     'These lines check to see if a NULL has been entered into the field from the
  959.     'DefaultDate subroutine, if it has, it is set to an empty string, the date from
  960.     'the database is also checked, if it is invalid, it to is set to an empty string
  961.     If Update_Time = "NULL" Then
  962.         Update_Time = ""
  963.     End If
  964.     On Error GoTo 0
  965.     Exit Sub
  966.  
  967. NoCompanyStripDates:
  968.  
  969.     Success = False
  970.     ErrorCode = Err
  971.     objError.ErrorCode = Err
  972.     objError.FunctionName = "clsCompany.StripDates"
  973.     If Err = 3146 Then
  974.         objError.Message = "Company, StripDates " & vbCrLf & Errors(0) & " "
  975.         ErrorMessage = Errors(0)
  976.     Else
  977.         objError.Message = "Company, StripDates "
  978.         ErrorMessage = Error(Err)
  979.     End If
  980.     objError.SQL = lsSelect
  981.     objError.Display vbExclamation
  982.     Resume Next
  983.  
  984.  
  985. End Sub
  986.  
  987. '********************************************************************************************************
  988. 'Title:     PadFields
  989. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  990. 'Purpose:   This routine Pads any fields with a space which do not allow zero length
  991. 'Purpose:   The Allow zero length property is set by default in Access databases and is
  992. '           used also in Oracle and SQLServer if the if fields are not padded with space
  993. '           the database won't add the record, sometimes this is desirable sometimes not
  994. 'Parameters:None
  995. 'Return:    Nothing
  996. '********************************************************************************************************
  997. Private Sub PadFields()
  998.  
  999. Dim liCount As Integer, BadCount As Integer, lsSelect As String
  1000.  
  1001.     If Not objConfiguration.DebugFlag Then
  1002.         On Error GoTo NoCompanyPadFields
  1003.     End If
  1004.  
  1005.     'These lines put a space into any field which does not allow zero length, so the
  1006.     'record can be added anyway
  1007.     If Trim(Contact) = "" Then
  1008.             Contact = " "
  1009.     End If
  1010.     On Error GoTo 0
  1011.     Exit Sub
  1012.  
  1013. NoCompanyPadFields:
  1014.  
  1015.     Success = False
  1016.     ErrorCode = Err
  1017.     objError.ErrorCode = Err
  1018.     objError.FunctionName = "clsCompany.PadFields"
  1019.     If Err = 3146 Then
  1020.         objError.Message = "Company, PadFields " & vbCrLf & Errors(0) & " "
  1021.         ErrorMessage = Errors(0)
  1022.     Else
  1023.         objError.Message = "Company, PadFields "
  1024.         ErrorMessage = Error(Err)
  1025.     End If
  1026.     objError.SQL = lsSelect
  1027.     objError.Display vbExclamation
  1028.     Resume Next
  1029.  
  1030.  
  1031. End Sub
  1032.  
  1033. '********************************************************************************************************
  1034. 'Title:     TrimPaddedFields
  1035. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  1036. 'Purpose:   This routine Trims the fields which have spaces at beginning or end
  1037. 'Parameters:None
  1038. 'Return:    Nothing
  1039. '********************************************************************************************************
  1040. Private Sub TrimPaddedFields()
  1041.  
  1042. Dim liCount As Integer, BadCount As Integer, lsSelect As String
  1043.  
  1044.     If Not objConfiguration.DebugFlag Then
  1045.         On Error GoTo NoCompanyTrimPaddedFields
  1046.     End If
  1047.  
  1048.     'This routine deletes the spaces from any padded fields
  1049.     Contact = Trim(Contact)
  1050.     On Error GoTo 0
  1051.     Exit Sub
  1052.  
  1053. NoCompanyTrimPaddedFields:
  1054.  
  1055.     Success = False
  1056.     ErrorCode = Err
  1057.     objError.ErrorCode = Err
  1058.     objError.FunctionName = "clsCompany.TrimPaddedFields"
  1059.     If Err = 3146 Then
  1060.         objError.Message = "Company, TrimPaddedFields " & vbCrLf & Errors(0) & " "
  1061.         ErrorMessage = Errors(0)
  1062.     Else
  1063.         objError.Message = "Company, TrimPaddedFields "
  1064.         ErrorMessage = Error(Err)
  1065.     End If
  1066.     objError.SQL = lsSelect
  1067.     objError.Display vbExclamation
  1068.     Resume Next
  1069.  
  1070.  
  1071. End Sub
  1072.  
  1073.  
  1074. '********************************************************************************************************
  1075. 'Title:     StoreProperties
  1076. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  1077. 'Purpose    This Sub Assigns the Properties of the Class to the
  1078. '           private class scratchpad variables
  1079. 'Parameters:None
  1080. 'Return:    Nothing
  1081. '********************************************************************************************************
  1082. Private Sub StoreProperties()
  1083.  
  1084.     mCompany_Id = Company_Id
  1085.     mCompany_Name = Company_Name
  1086.     mAddress1 = Address1
  1087.     mAddress2 = Address2
  1088.     mCity = City
  1089.     mState = State
  1090.     mZip = Zip
  1091.     mPhone = Phone
  1092.     mFax = Fax
  1093.     mContact = Contact
  1094.     mUpdated_By = Updated_By
  1095.     mUpdate_Module = Update_Module
  1096.     mUpdate_Time = Update_Time
  1097.  
  1098. End Sub
  1099.  
  1100. '********************************************************************************************************
  1101. 'Title:     RetrieveProperties
  1102. 'Author:    DesignGrid by W. David Ewing, Copyright 1998
  1103. 'Purpose    This Sub Assigns the ScratchPad Variable Values back to the Class properties
  1104. 'Parameters:None
  1105. 'Return:    Nothing
  1106. '********************************************************************************************************
  1107. Private Sub RetrieveProperties()
  1108.  
  1109.     Company_Id = mCompany_Id
  1110.     Company_Name = mCompany_Name
  1111.     Address1 = mAddress1
  1112.     Address2 = mAddress2
  1113.     City = mCity
  1114.     State = mState
  1115.     Zip = mZip
  1116.     Phone = mPhone
  1117.     Fax = mFax
  1118.     Contact = mContact
  1119.     Updated_By = mUpdated_By
  1120.     Update_Module = mUpdate_Module
  1121.     Update_Time = mUpdate_Time
  1122.  
  1123. End Sub
  1124.